home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Yerk 3.6.7 / yerk 367 / tool+ / popUp7 (.txt) < prev    next >
Microsoft Windows Help File Content  |  1994-12-08  |  6KB  |  134 lines
  1. :CLASS popUps <super Control 4 <indexed
  2. \ late bound for subclasses to work - note that there can be no instances
  3. \  of this class..otherwise HANDLE: is recursive
  4.     :M  HANDLE: handle: [ ^base ] ;M
  5.     :M  CTLHANDLE: get: ctlhndl ;M
  6.     :M  GETCTLTITLE: ( -- addr len) ^base getTitle: control ;M
  7.     \ ( cfa0...cfaN resid -- )  put resid and handlers in menu
  8.     :M  PUT:   put: resId  ^base put: array  ;M
  9.     :M  PUTITEM: put: super ;M
  10.     :M  GETITEM: ( -- item) get: super ;M
  11.     :M  EXEC: ( part# --)
  12.         IF getItem: self -> mitem
  13.            ^base -> theMenu get: resID -> menuID
  14.             mitem 1- at: self execute exec: action
  15.             get: super put: myValue
  16.         THEN ;M
  17.     \ ( item# -- addr len )  get string for item #
  18.     :M  GET:  ( item -- addr len ) handle: self  swap makeInt
  19.         buf255 +base  call GetItem  buf255 count ;M
  20.     :M  GETTITLE: ( -- addr len) handle: self >ptr 14 + count ;M
  21.     :M  GETNAME: ( -- addr len) getItem: self get: self ;M
  22.     :M  GETMAXVAL: ( -- n) word0 ctlHandle: self call getCtlMax i->l ;M
  23.     :M  SETMAXVAL: ( n __) ctlHandle: self swap makeint call setCtlMax ;M
  24.     \ ( addr len -- )  Append a menu item
  25.     :M  ADD:   Str255  handle: self ?new swap  call AppendMenu
  26.         getMaxVal: self 1+ setMaxVal: self ;M
  27.     \ ( ind --) remove a menu item
  28.     :M  REMOVE: ( ind --) handle: self swap makeint call delMenuItem
  29.         getMaxVal: self 1- setMaxVal: self ;M
  30.     \ ( addr len item# -- )  replace menu item string, but don't redraw
  31.     :M  (SET): alive: [ obj: myWindow ]
  32.         IF >r str255 >r handle: self ?new
  33.             r> r> swap >r makeInt r> call SetItem
  34.         ELSE 2drop drop
  35.         THEN ;M
  36.     \ ( addr len item# -- )  replace menu item string and draw menu
  37.     :M  SET:  (set): self alive: [ obj: myWindow ]
  38.         IF  draw: super THEN ;M
  39.     :M  (REDRAW): ( item --) dup 0= swap getItem: self = or IF draw: [ obj: myWindow ] THEN ;M
  40.     \ ( item# -- )  Enable a menu item
  41.     :M  ENABLE: { item -- } handle: self item makeInt call EnableItem
  42.         item (redraw): self ;M
  43.     \ ( item# -- )  Grey and disable an item
  44.     :M  DISABLE: { item -- } handle: self item makeInt call DisableItem
  45.         item (redraw): self ;M
  46. \ return the number of items in the menu
  47.     :M  MITEMS: word0 handle: self call countMItems i->l ;M
  48.     :M  CHECKED?: ( item -- b) ^base get: control = ;M
  49.     :M  CLASSINIT: nullcfa fill: super nullcfa put: action ;M
  50. ;CLASS
  51. :CLASS popUpMenu <super popUps
  52.     rect bounds
  53.     int    valueParm
  54.     :M  HANDLE: ptr: ctlhndl 28 + @ -base @ -base @ ;M
  55.     :M  PUTRECT: put: bounds ;M
  56. \ *** next three methods apply to the Title box, not the popup ***
  57. \ 0=left;1=center;255=right
  58.     :M  JUSTIFY: ( n --) get: valueParm $ ff00 and or put: valueParm ;M
  59. \ $100=bold;$200=italic;$400=underline;$800=outline;$1000=shadow
  60.     :M FACE: ( n --) get: valueParm $ e0ff and or put: valueParm ;M
  61. \ $2000=condense;$4000=extend;$8000=nostyle
  62.     :M STYLE: ( n --) get: valueParm $ 1fff and or put: valueParm ;M
  63. \ build a popup; procid is set to 1=fixedwidth;4=addresmen;8=useWFont
  64.     :M  NEW:  { x y addr len theWind \ tWid -- }
  65.         theWind saveFont
  66.         get: procID 8 and 0=
  67.         IF 0 tFont 12 tSize THEN addr len tWidth -> tWid    \ width of title
  68.         0 abs: theWind  Abs: bounds addr len str255
  69.         w 256 int: valueParm int: resId twid makeint  1008 get: procId +
  70.         makeInt  ^base
  71.         call NewControl put: ctlhndl
  72.         ^base get: ctlhndl set-ctl-obj
  73.         theWind put: myWindow theWind restFont ;M
  74.       :M  GETNEW: { \ theWind -- } get: myWindow -> theWind
  75.          theWind 0= classerr" 190 theWind saveFont
  76.          0 int: resID theWind +base call getNewControl dup 0= classerr" 170
  77.          put: ctlhndl
  78.         ^base get: ctlhndl set-ctl-obj
  79.         get: myValue ^base put: control theWind restFont ;M
  80. ;CLASS
  81. \ Example:
  82. \ ctlwind suz
  83. \ " .rsrc" openresfile
  84. \ 5 popupmenu bob
  85. \ 100 50 160 69 putrect: bob
  86. \ 128 putresid: bob 8 init: bob
  87. \ example: suz
  88. \ 100 50 " myTitle:" suz new: bob
  89. \ : one mitem home . ;
  90. \ 'c one fill: bob
  91. \ NB. When using PopUpDlgMenus in SaveDlg objects, know that the fill:
  92. \   method does not fill the instance variable 'myValue' of the control
  93. \   object. This means that even though the popup looks correct, if the
  94. \   user doesn't click in the menu, the ivar will not be filled. So access
  95. \   of the popup value by the getItem: method after the dialog is closed
  96. \   will not yield the correct number. For right now, must initialize each
  97. \   popup to the stored value of the saveDlg parameters by hand.
  98. :CLASS popUpDlgMenu <super popUps
  99.     int itemNo
  100.     :M ITEMNo:     ( -- n)    get: itemNo ;M
  101.     :M PUTITEMNo: ( n --) put: itemNo ;M
  102. \ returns handle to the control object, not the menu
  103. \ also, be careful...need to putItemNo: at compile time
  104.     :M CTLHANDLE: ( -- hndl) get: itemNo dup 0= classerr" 191
  105.         handle: [ obj: myWindow ] dup put: ctlhndl ;M
  106.     :M HANDLE: ctlHandle: self >ptr 28 + @ -base @ -base @ ;M
  107.     :M EXECACTION: handle: self drop get: itemNo get: [ obj: myWindow ] putItem: self
  108.         true exec: self returnToModal ;M
  109.     :M SETITEM: ( --) ctlHandle: self drop getItem: self putItem: self ;M
  110.     :M  GETNAME: ( -- addr len) setItem: self getItem: self get: self ;M
  111. ;CLASS
  112. \ Example:
  113. \ 3 savedlg bob1
  114. \ 402 putresid: bob1
  115. \ " .rsrc" openresfile
  116. \ 5 popUpDlgMenu suz1
  117. \ 402 putresid: suz1
  118. \ bob1 putWindow: suz1
  119. \ : uu " .rsrc" openresfile getnew: bob1 modal: bob1 ;
  120. \ 'c returnToModal 2 to: bob1
  121. \ 0 value huh
  122. \ : ll handle: suz1 drop get: theItem get: bob1 putItem: suz1
  123. \     true exec: suz1 returnToModal ;
  124. \ : ll execAction: suz1 ;
  125. \ : dosave save: bob1 closer ;
  126. \ 'c dosave 1 to: bob1
  127. \ 'c ll 2 to: bob1
  128. \ : one1 1 ++> huh ;
  129. \ : two 2 ++> huh ;
  130. \ : three 3 ++> huh ;
  131. \ : four 4 ++> huh ;
  132. \ : five 5 ++> huh ;
  133. \ 5 'cfas one1 two three four five 400 put: suz1
  134.